perm filename KK[NEW,LCS] blob
sn#561084 filedate 1981-02-01 generic text, type T, neo UTF8
05400 SETZM I ;I=0
05500 MOVEI 1 ;N=1
05600 MOVEM N
05700 20 CALL UNSTUF(Q,V,JT)
05900 MOVEI 1,@1(16) ;J=V(N-3)
05920 ADD 1,N
05940 SUBI 1,4
05960 KIFIX 15,(1) ;C GET THE CODE NUM.
06100 KIFIX 11,-1(1) ;NX=V(N-4)-1+N
06200 ADD 11,N ;C HOW FAR DO WE GO FOR THIS ITEM?
06220 SOJ 11,
06300 CAIE 15,=16 ;IF(J.EQ.16)GO TO 36
06320 CAIN 15,=8 ;IF(J.EQ.8)GO TO 36
06330 JRST S36
06340 CAIN 15,=11 ;IF(J.EQ.11)GO TO 36
06350 JRST S36
06360 MOVEI 14,3 ;M=3
06380 S22: CAMN 11,N ;22 IF(N.EQ.NX)GO TO 32
06385 JRST S32
06390 AOJ 14, ;M=M+1
06400 AOS I ;I=I+1
06500 MOVEI 1,@(16) ;L=Q(I)/10000.0
06520 ADD 1,I
06540 MOVE 2,(1)
06560 FDVR 2,[10000.0]
06580 KIFIX 13,2 ;AC13 IS L
06600 MOVM 12,13 ;C GET THE PARAM NUM. LL=IABS(L)
06900 S24: CAMN 12,14 ;24 IF(LL.EQ.M)GO TO 21
06920 JRST S21
07000 CAME 11,N ;IF(N.NE.NX)GO TO 25
07020 JRST S25
07050 SOS I ;I=I-1
07075 JRST S32 ;GO TO 32
07100 S25: MOVEI 1,@1(16)
07120 ADD 1,N
07140 SETZM -1(1) ;25 V(N)=0 PUT BACK IN THE ZERO PARAMS.
07350 AOJ 14, ;M=M+1
07400 S23: AOS N ;23 N=N+1
07500 JRST S24 ;GO TO 24
07600 S21: IMULI 13,=10000 ;21 X=Q(I)-L*10000
07620 FLTR 13,13 ;C GET BACK THE REAL CONTENTS OF THE PARAM.
07640 MOVEI 1,@(16)
07660 ADD 1,I
07680 FSBR 1,13 ;AC1 IS X
07900 MOVEI 2,@1(16) ;V(N)=X
07920 ADD 2,N
07922 MOVEM 1,-1(2)
07950 AOS N ;N=N+1
08000 JRST S22 ;GO TO 22
08100 S36: CAMN 11,N ;36 IF(N.EQ.NX)GO TO 32
08110 JRST S32
08120 MOVE 5,N ;DO 35 K=N,NX-1
08200 S35: AOS I ; I=I+1
08210 MOVEI 2,@1(16) ;GET LOC OF V ARRAY
08400 MOVEI 1,@(16) ;LOC OF Q ARRAY 35 V(K)=Q(I)
08410 ADD 2,N
08430 ADD 1,I
08440 MOVE 6,(1) ;Q(I)
08450 MOVEM 6,-1(2)
08460 AOS N
08470 CAME 11,N
08480 JRST S35 ;N=NX
08600 S32: MOVE I
08610 CAMGE @2(16) ;32 IF(I.LT.JT)GO TO 20
08620 JRST S20
08700 MOVE N ;JT=N
08710 MOVEM @2(16) ;GET NEW WD CNT